home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / cmplrtst.lha / sort / fxqsort.scm < prev    next >
Encoding:
Text File  |  1990-03-27  |  2.1 KB  |  92 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (declare (usual-integrations 1+ -1+ + = < > integer-divide)
  4.      (integrate-primitive-procedures
  5.       (-1+ minus-one-plus-fixnum)
  6.       (1+ one-plus-fixnum)
  7.       (+ plus-fixnum)
  8.       (= equal-fixnum?)
  9.       (< less-than-fixnum?)
  10.       (> greater-than-fixnum?)
  11.       (integer-divide divide-fixnum)))
  12.  
  13. (let-syntax ((define-integrable
  14.            (macro (params . body)
  15.          `(begin
  16.             (declare (integrate-operator ,(car params)))
  17.             (define ,(car params)
  18.               (named-lambda ,params
  19.             (declare (integrate ,@(cdr params)))
  20.             ,@body))))))
  21.  
  22. (define (sort obj pred)
  23.   (cond ((pair? obj)
  24.      (vector->list (sort! (list->vector obj) pred)))
  25.     ((vector? obj)
  26.      (sort! (vector-copy obj) pred))
  27.     ((null? obj)
  28.      '())
  29.     (else
  30.      (error "sort: argument should be a list or a vector"))))
  31.  
  32. (define (sort! vec pred)
  33.   (define-integrable (quo x y)
  34.     (car (integer-divide x y)))
  35.   
  36.   (define-integrable (exchange! i j)
  37.     (let ((old (vector-ref vec i)))
  38.       (vector-set! vec i (vector-ref vec j))
  39.       (vector-set! vec j old)))
  40.  
  41.   (define (split a b)
  42.     (cond ((= b (1+ a))
  43.        (if (not (pred (vector-ref vec a)
  44.               (vector-ref vec b)))
  45.            (exchange! a b)))
  46.       ((< a b)
  47.        (let* ((middle (quo (+ a b) 2))
  48.           (val (vector-ref vec middle)))
  49.  
  50.          (define (split-1-end i j)
  51.            (if (> i b)
  52.            (begin
  53.              (exchange! middle b)
  54.              (split a (-1+ b)))
  55.            (begin
  56.              (split a j)
  57.              (split i b))))
  58.  
  59.          (define (split-1 i j)
  60.            (cond ((> i j)
  61.               (split-1-end i j))
  62.              ((pred (vector-ref vec i) val)
  63.               (split-1 (1+ i) j))
  64.              (else (split-2 i j))))
  65.  
  66.          (define (split-2-end i j)
  67.            (if (< j a)
  68.            (begin
  69.              (exchange! a middle)
  70.              (split (1+ a) b))
  71.            (begin
  72.              (split a j)
  73.              (split i b))))
  74.  
  75.          (define (split-2 i j)
  76.            (cond ((< j i)
  77.               (split-2-end i j))
  78.              ((pred val (vector-ref vec j))
  79.               (split-2 i (-1+ j)))
  80.              (else
  81.               (exchange! i j)
  82.               (split-1 (1+ i) (-1+ j)))))
  83.   
  84.          (split-1 a b)))))
  85.  
  86.   (if (not (vector? vec))
  87.       (error "sort!: argument must be a vector" vec))
  88.  
  89.   (split 0 (-1+ (vector-length vec)))
  90.   vec)
  91.  
  92. ) ;; End of let-syntax